home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / disasm.scm < prev    next >
Text File  |  1995-10-13  |  4KB  |  133 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  3.  
  4.  
  5. ; This is file assem.scm.
  6.  
  7. ;;;; Disassembler
  8.  
  9. ; This defines a command processor command
  10. ;      dis <expression>
  11. ; that evaluates <expression> to obtain a procedure or lambda-expression,
  12. ; which is then disassembled.
  13.  
  14. ; Needs:
  15. ;   template? template-name template-code
  16. ;   closure? closure-template
  17. ;   code-vector-...
  18. ;   location-name
  19.  
  20. (define-command-syntax 'dis "[<exp>]" "disassemble procedure"
  21.   '(&opt expression))
  22.  
  23. (define (dis . maybe-exp)
  24.   (disassemble (if (null? maybe-exp)
  25.            (focus-object)
  26.            (evaluate (car maybe-exp) (environment-for-commands)))))
  27.  
  28. (define (disassemble obj)
  29.   (really-disassemble (coerce-to-template obj) 0)
  30.   (newline))
  31.  
  32. (define (really-disassemble tem level)
  33.   (write (template-name tem))
  34.   (let loop ((pc 0))
  35.     (if (< pc (code-vector-length (template-code tem)))
  36.         (loop (write-instruction tem pc level #t)))))
  37.  
  38. (define (newline-indent n)
  39.   (newline)
  40.   (do ((i n (- i 1)))
  41.       ((= i 0))
  42.     (display #\space)))
  43.  
  44. (define (write-pc pc)
  45.   (if (< pc 100) (display " "))
  46.   (if (< pc 10) (display " "))
  47.   (write pc))
  48.  
  49. (define (write-instruction template pc level write-sub-templates?)
  50.   (let* ((code (template-code template))
  51.          (opcode (code-vector-ref code pc)))
  52.     (newline-indent (* level 3))
  53.     (write-pc pc)
  54.     (display " (")
  55.     (write (enumerand->name opcode op))
  56.     (let ((pc (if (= opcode op/computed-goto)
  57.           (display-computed-goto pc code)
  58.           (print-opcode-args opcode (+ pc 1) code template
  59.                      level write-sub-templates?))))
  60.       (display #\) )
  61.       pc)))
  62.  
  63. (define op/computed-goto (enum op computed-goto))
  64.  
  65. (define (display-computed-goto pc code)
  66.   (display #\space)
  67.   (let ((count (code-vector-ref code (+ pc 1))))
  68.     (write count)
  69.     (do ((pc (+ pc 2) (+ pc 2))
  70.      (count count (- count 1)))
  71.     ((= count 0) pc)
  72.       (display #\space)
  73.       (write `(=> ,(+ pc (+ (+ (* (code-vector-ref code pc)
  74.                   byte-limit)
  75.                    (code-vector-ref code (+ pc 1)))
  76.                 2)))))))
  77.  
  78. (define (print-opcode-args op pc code template level write-templates?)
  79.   (let ((specs (vector-ref opcode-arg-specs op)))
  80.     (let loop ((specs specs) (pc pc))
  81.       (cond ((or (null? specs)
  82.          (= 0 (arg-spec-size (car specs))))
  83.          pc)
  84.         (else
  85.          (display #\space)
  86.          (print-opcode-arg specs pc code template level write-templates?)
  87.          (loop (cdr specs) (+ pc (arg-spec-size (car specs)))))))))
  88.  
  89. (define (arg-spec-size spec)
  90.   (case spec
  91.     ((nargs byte index stob) 1)
  92.     ((offset) 2)
  93.     (else 0)))
  94.  
  95. (define (print-opcode-arg specs pc code template level write-templates?)
  96.   (case (car specs)
  97.     ((nargs byte)
  98.      (write (code-vector-ref code pc)))
  99.     ((index)
  100.      (let ((thing (template-ref template (code-vector-ref code pc))))
  101.        (write-literal-thing thing level write-templates?)))
  102.     ((offset)
  103.      (write `(=> ,(+ pc (+ (get-offset pc code)
  104.                (apply + (map arg-spec-size specs)))))))
  105.     ((stob)
  106.      (write (enumerand->name (code-vector-ref code pc) stob)))))
  107.  
  108. (define (get-offset pc code)
  109.   (+ (* (code-vector-ref code pc)
  110.     byte-limit)
  111.      (code-vector-ref code (+ pc 1))))
  112.  
  113. (define (write-literal-thing thing level write-templates?)
  114.   (cond ((location? thing)
  115.      (write (or (location-name thing)
  116.             `(location ,(location-id thing)))))
  117.     ((not (template? thing))
  118.      (display #\')
  119.      (write thing))
  120.     (write-templates?
  121.      (really-disassemble thing (+ level 1)))
  122.     (else
  123.      (display "..."))))
  124.  
  125. (define byte-limit (expt 2 bits-used-per-byte))
  126.  
  127.  
  128. (define (coerce-to-template obj)    ;utillity for various commands
  129.   (cond ((template? obj) obj)
  130.     ((closure? obj) (closure-template obj))
  131.     ((continuation? obj) (continuation-template obj))
  132.     (else (error "expected a procedure or continuation" obj))))
  133.